home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / tdecl / type-declaration-analysis.scm < prev   
Encoding:
Text File  |  1994-09-27  |  3.6 KB  |  96 lines  |  [TEXT/CCL2]
  1.  
  2. ;;; This processes type declarations (data, type, instance, class)
  3. ;;; Static errors in type declarations are detected and type decls
  4. ;;; are replaced by type definitions.  All code (class and instance
  5. ;;; definitions) is moved to the module decls.
  6.  
  7. (define *synonym-refs* '())
  8.  
  9. (predefine (add-derived-instances modules))
  10.    ; in derived/derived-instances.scm
  11.  
  12. (define (process-type-declarations modules)
  13. ;;; Convert data & type decls to definitions
  14.  (let ((interface? (interface-module? (car modules))))
  15.   (setf *synonym-refs* '())
  16.   (watch-for-undefined-symbols)
  17.   (walk-modules modules
  18.    (lambda ()
  19.      (setf (module-alg-defs *module*)
  20.        (map (function algdata->def) (module-algdatas *module*)))
  21.      (setf (module-synonym-defs *module*)
  22.        (map (function synonym->def) (module-synonyms *module*)))
  23.      (when (not interface?)
  24.     (dolist (ty (default-decl-types (module-default *module*)))
  25.         (resolve-type ty)))))
  26.         ;; A test to see that ty is in Num and is a monotype is needed here.
  27.   ;; In an interface you can't do the superclasses or synonyms since
  28.   ;; definitions of imported objects may not be available.
  29.   (unless interface?
  30.    (multiple-value-bind (ty vals) (topsort *synonym-refs*)
  31.      (when (eq? ty 'cyclic) (signal-recursive-synonyms vals))))
  32.   ;; Convert class declarations and instance declarations to definitions.
  33.   (walk-modules modules
  34.    (lambda ()
  35.      (setf (module-class-defs *module*)
  36.        (map (function class->def) (module-classes *module*)))))
  37.   (unless interface?
  38.     (walk-modules modules
  39.        (lambda ()
  40.           (dolist (class (module-class-defs *module*))
  41.             (setup-class-slots class))))
  42.     (walk-modules modules
  43.        (lambda ()
  44.           (dolist (class (module-class-defs *module*))
  45.             (create-selector-functions class '#f))))
  46.     (install-instance-links))
  47.   (walk-modules modules
  48.     (lambda ()
  49.      (setf (module-instance-defs *module*) '())
  50.      (dolist (inst-decl (module-instances *module*))
  51.        (let ((inst (instance->def inst-decl interface?)))
  52.      (when (not (eq? inst '#f))
  53.             (push inst (module-instance-defs *module*)))))
  54.      ;; Deriving decls live in the symbol table
  55.      (dolist (deriving-decl (module-derivings *module*))
  56.        (deriving-decl->deriving deriving-decl))))
  57.   (unless interface? (add-derived-instances modules))
  58.   (walk-modules modules
  59.    (lambda ()
  60.      (dolist (inst (module-instance-defs *module*))
  61.        (expand-instance-decls inst interface?))
  62.        (unless interface? (add-runtime-type-definitions))))
  63.   (unless interface?
  64.    (walk-modules modules
  65.     (lambda ()
  66.      (dolist (inst (module-instance-defs *module*))
  67.      (check-inst-type inst))
  68.      (dolist (ty (default-decl-types (module-default *module*)))
  69.     (resolve-type ty))))
  70.    ;;; Here we clean up class definitions coming in from interfaces.  These
  71.    ;;; don't have super* set up.  This really doesn't need to be done
  72.    ;;; every time we see the class but it's not worth caching.
  73.    (walk-modules (get-all-interfaces)
  74.     (lambda ()
  75.       (dolist (class (module-class-defs *module*))
  76.         (setup-class-slots class)
  77.         (create-selector-functions class '#t))))
  78.    (show-undefined-symbols)
  79.    )))
  80.  
  81. (define (signal-recursive-synonyms vals)
  82.   (fatal-error 'recursive-synonyms
  83.     "There is a cycle in type synonym definitions involving these types:~%~a"
  84.     vals))
  85.  
  86. (define (add-new-module-decl decl)
  87.   (setf (module-decls *module*) (cons decl (module-decls *module*))))
  88.  
  89. (define (add-new-module-def var value)
  90.   (add-new-module-decl
  91.    (**define var '() value)))
  92.  
  93. (define (add-new-module-signature var signature)
  94.   (add-new-module-decl
  95.    (**signdecl/def (list var) signature)))
  96.